home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / ppl.emc < prev    next >
Encoding:
Text File  |  1992-07-05  |  25.5 KB  |  760 lines
  1. ;
  2. ;       Proper Paralation Lisp
  3. ;
  4. ;       File            : ppl
  5. ;
  6. ;       Contents        : export list:    elwise
  7. ;                    match
  8. ;                    move
  9. ;                    depfun
  10. ;                    choose
  11. ;                    enum
  12. ;                    count
  13. ;                    position
  14. ;                    get
  15. ;                    field-ref (+ setter)
  16. ;                    field-length
  17. ;                    make-paralation
  18. ;                    fieldp
  19. ;
  20. ;       Description     : So called proper paralation lisp because it run
  21. ;              on the processor array. This is better than the last 
  22. ;              version (plisp) as the underlying system is able
  23. ;              to allocate processors in rectangles. So perhaps this
  24. ;              should be bpl (better paralation lisp). This code
  25. ;              rewires the given elwise form into a (hefty) piece
  26. ;              of singular code with calls to parallel 
  27. ;              primitives.
  28. ;
  29. ;       Author          : SCM
  30. ;
  31. ;       Change History  :
  32. ;
  33. ;       Date    Name    Comment
  34. ;     02:06:92  SCM     Created - hacked from plisp.emc
  35. ;     17:06:92  SCM    Added attributes slot and modified get
  36.  
  37.  
  38. ; Include Files
  39. ; ======= =====
  40.  
  41. ; This file has to be run through a preprocessor (empp, uses cpp and sed)
  42. ; to create  a EuLisp readable file. This is because it needs access to
  43. ; constants used by the data parallel lisp primitives written in mpl. The
  44. ; constants distinguish the various lisp types and the types of binary,
  45. ; unary and relational operators available.
  46.  
  47. #include "mp_arith.h"
  48. #include "mp_type.h"
  49.  
  50. (defmodule ppl (standard0 plural ppl-ll) ()
  51.  
  52.  
  53. ; System Configuration
  54. ; ====== =============
  55.  
  56. ; These constants are system defined, the first three indicate the number of
  57. ; physical processors available, GC-TOP varies with the size of heap.
  58.  
  59.   (setq MP-Config 512)
  60.   (setq MP-X-Config 16)
  61.   (setq MP-Y-Config 32)
  62.   (setq GC-TOP (mp-sb-ref))
  63.  
  64.  
  65. ; Debug
  66. ; =====
  67.  
  68. ; xecs are a hangover from eubang (the plurals module) and the connection
  69. ; machine lisp module which was experimentally developed before plisp,
  70. ; it is included here purely for debug purposes as it is the most
  71. ; primitive way of looking at parallel objects, which can be useful
  72. ; when something has gone wrong.
  73.  
  74.   (defclass xec ()
  75.     ((context
  76.       initarg context
  77.       reader  context)
  78.      (offset
  79.       initarg offset
  80.       reader  offset))
  81.     constructor (allocate-xec context offset)
  82.     predicate xecp)
  83.  
  84.   (defun make-xec (c o)
  85.     (become-strange (allocate-xec c o)))
  86.   
  87.   (defmethod generic-prin ((p xec) str)
  88.     (format str "#x(")
  89.     (mp-print (context p) (offset p) () () str)
  90.     (format str ")")
  91.     p)
  92.   
  93.   (defmethod generic-write ((p xec) str)
  94.     (format str "#x(")
  95.     (mp-print (context p) (offset p) () () str)
  96.     (format str ")")
  97.     p)
  98.  
  99.  
  100. ; Paralation Structure
  101. ; ========== =========
  102.  
  103. ; The paralation is a handle on the set of processor you are working
  104. ; on, it contains all sorts of useful information, like how many
  105. ; there are, if they have any shape.
  106. ; Fields, the data parallel objects in paralation lisp, all belong to
  107. ; one (and only one) paralation, hence they have pointer to their
  108. ; paralation structure. A special field, called the index field and
  109. ; enumerates the elements of the paralation is associated with the
  110. ; paralation and so we have a pointer to this field in the paralation
  111. ; structure as well.
  112. ;    We now have the extra slot, attributes, which can be used to
  113. ; store useful information about the paralation, for example in the
  114. ; case of a rectangle its dimensions (in contexts!).
  115.  
  116.   (defclass paralation-internal ()
  117.     ((contexts 
  118.       initarg contexts
  119.       reader contexts-internal)
  120.     (index
  121.      initarg index
  122.      accessor index-internal)
  123.     (shape
  124.      initarg shape
  125.      accessor shape-internal)
  126.     (attributes 
  127.      initarg attributes
  128.      accessor attributes)
  129.     (length
  130.      initarg length
  131.      reader length-internal))
  132.     constructor (allocate-paralation contexts length))
  133.  
  134.  
  135. ; Paralation Object Structure
  136. ; ========== ====== =========
  137.  
  138. ; Paralation objects, anything that require a paralation to make any
  139. ; sense, namely a field or a mapping, which describe communication
  140. ; patterns between fields. These all contain a paralation and a list
  141. ; of offsets into the data parallel heaps which is where the actual
  142. ; data is.
  143.  
  144.   (defclass paralation-object ()
  145.     ((paralation
  146.       initarg paralation
  147.       reader paralation)
  148.     (offsets
  149.      initarg offsets
  150.      accessor offsets))
  151.     predicate paralation-object-p)
  152.   
  153.  
  154. ; Field Structure
  155. ; ===== =========
  156.  
  157. ; First we deal with fields. Notice that we wrap the field allocator
  158. ; with a form which marks the structure as being strange, this is so
  159. ; the GCer can spot tyhem and list them so we can tell the MasPar
  160. ; which of it's objects are still around.
  161.  
  162.   (defclass field (paralation-object)
  163.     ()
  164.     constructor (allocate-field paralation offsets)
  165.     predicate fieldp)
  166.  
  167.   (defun make-field (p o)
  168.     (become-strange (allocate-field p o)))
  169.  
  170. ; The paralation contains the data we are interested in, but in
  171. ; general we have the field structures, so here are functions to get
  172. ; the appropriate values from a field structure.
  173.  
  174.   (defun contexts (p-o) (contexts-internal (paralation p-o)))
  175.  
  176.   (defun index (p-o) (index-internal (paralation p-o)))
  177.  
  178.   (defun shape (p-o) (shape-internal (paralation p-o)))
  179.  
  180.   ((setter setter) shape (lambda (f v) 
  181.    ((setter shape-internal) (paralation f) v)))
  182.  
  183.   (defun field-length (p-o) (length-internal (paralation p-o)))
  184.   
  185. ; Notice how these methods use a combination of immediate and indirect
  186. ; accessors, anyway - now we can print them.
  187.  
  188.   (defmethod generic-prin ((f field) str)
  189.     (if (not (attributes (paralation f)))
  190.       (progn
  191.     (format str "#F(")
  192.     (mp-print (car (contexts f)) (car (offsets f)) () () str)
  193.     (if (cdr (contexts f)) (format str "... )") (format str ")")))
  194.       (let ((context-width (min (vector-ref (attributes (paralation f)) 0) MP-X-Config)))
  195.     (format str "\n#F(")
  196.     (mp-print (car (contexts f)) (car (offsets f)) context-width
  197.           (< context-width (vector-ref (attributes (paralation f)) 0)) str)
  198.     (if (< MP-Y-Config (vector-ref (attributes (paralation f)) 1))
  199.       (format str "\n ... )") (format str " )")))))
  200.  
  201.   (defmethod generic-write ((f field) str)
  202.     (if (not (attributes (paralation f)))
  203.       (progn
  204.     (format str "#F(")
  205.     (mp-print (car (contexts f)) (car (offsets f)) () () str)
  206.     (if (cdr (contexts f)) (format str "... )") (format str ")")))
  207.       (let ((context-width (min (vector-ref (attributes (paralation f)) 0) MP-X-Config)))
  208.     (format str "\n#F(")
  209.     (mp-print (car (contexts f)) (car (offsets f)) context-width
  210.           (< context-width (vector-ref (attributes (paralation f)) 0)) str)
  211.     (if (< MP-Y-Config (vector-ref (attributes (paralation f)) 1))
  212.       (format str "\n   ... )") (format str " )")))))
  213.  
  214. ;  (defmethod generic-prin ((f field) str)
  215. ;    (format str "#F(")
  216. ;    (mapcar (lambda (c o) (mp-print c o () () str)) (contexts f) (offsets f))
  217. ;    (format str ")")
  218. ;    f)
  219. ;  
  220. ;  (defmethod generic-write ((f field) str)
  221. ;    (format str "#F(")
  222. ;    (mapcar (lambda (c o) (mp-print c o () () str)) (contexts f) (offsets f))
  223. ;    (format str ")")
  224. ;    f)
  225.   
  226.  
  227. ; Processor Management
  228. ; ========= ==========
  229.  
  230. ; Paralation Lisp abstracts the number of processors, it does this by
  231. ; having a list of contexts on which the paralation is allocated, data
  232. ; parallel operations are run on each of these one after another. 
  233. ; A context will be a collection of global contexts, that is ones that
  234. ; use the entire array and one that uses only part of the array. We
  235. ; reuse the same global context and pre-allocate it.
  236.  
  237.   (setq MP-Context (mp-make-context MP-X-Config MP-Y-Config))
  238.  
  239.  
  240.   (setq MP-Offsets (cons (mp-scan-op MP-Context (mp-set MP-Context 
  241.                             (mp-bang MP-Context 1)
  242.                             0 0)
  243.                      MP_PLUS) ()))
  244.  
  245.   (setq MP-Nil (mp-bang MP-Context ()))
  246.  
  247. ; This will ensure the global context is garbage collected as we have
  248. ; nailed it into the environment in a form that can be spotted by the
  249. ; collector. 
  250.  
  251.   (setq GC-Protect (list (make-xec MP-Context (car MP-Offsets))
  252.              (make-xec MP-Context MP-Nil)))
  253.  
  254. ; As we allocate large paralations we reuse exisiting indexes for the
  255. ; global context compontents, the two variables below are useful for
  256. ; keeping track of these things and manipulating them in parallel
  257.  
  258.   (setq VMP-Config MP-Config)
  259.   (setq PMP-Config (mp-bang MP-Context MP-Config))
  260.  
  261.   (setq GC-Protect (cons (make-xec MP-Context PMP-Config) GC-Protect))
  262.   
  263. ; As more virtual pes are allocated we need to number them, we reuse
  264. ; the enumerations of the global contexts as they are the same for all
  265. ; paralations and are immutable. Each time another gklobal context is
  266. ; needed produce an enumeration for it (m -> m + config -1)
  267.  
  268.   (defun enough-virtual-pes-p 
  269.     ;; determines wether more enumerations of the global context are needed
  270.     (required) (< required (+ VMP-Config MP-Config)))
  271.  
  272.   (defun more-processors (required)
  273.     ;; if needed allocates more enumerations of the global context
  274.     (labels ((find-last (offsets)
  275.            ;; descends list of enumerations to the last cons cell
  276.            ;; extra enumerations are then tagged onto the list
  277.            (if (cdr offsets) (find-last (cdr offsets))
  278.          ((setter cdr) offsets (make-rest (car offsets)))))
  279.              (make-rest (offset)
  280.            ;; creates list of as many other enumeration nodes as required
  281.            ;; and GC protects them
  282.            (if (enough-virtual-pes-p required) ()
  283.          (let ((new-ofst (mp-bin-op MP-Context offset 
  284.                         PMP-Config MP_PLUS)))
  285.            (setq VMP-Config (+ VMP-Config MP-Config))
  286.            (setq GC-Protect (cons (make-xec MP-Context new-ofst)
  287.                       GC-Protect))
  288.            (cons new-ofst (make-rest new-ofst))))))
  289.       (find-last MP-Offsets)))
  290.   
  291.   (defun make-hacked-context (size)
  292.     (if (= size 1) (mp-make-context 1 1)
  293.       (let* ((width (ceiling (sqrt (/ size 2))))
  294.          (ctxt (mp-make-context width (ceiling (/ (* 1.0 size) width))))
  295.          (ofst (mp-context ctxt))
  296.          (tmp-pspace (mp-ps-ref))
  297.          (dummy (mp-sb-set tmp-pspace))
  298.          (enum (mp-scan-op ctxt (mp-bang ctxt 1) MP_PLUS)))
  299.     (mp-if ctxt (mp-rel-op ctxt enum (mp-bang ctxt size) MP_LE))
  300.     (mp-else ctxt)
  301.     (mp-assign ctxt ofst (mp-bang ctxt '(() ())))
  302.     (mp-fi ctxt)
  303.     (mp-ps-set tmp-pspace)
  304.     (mp-sb-set GC-TOP)
  305.     ctxt)))
  306.  
  307.   (defun get-contexts (required)
  308.     ;; allocates contexts for a new paralation, creates new global
  309.     ;; contexts if needed and probably one partial context unigue to
  310.     ;; this paralation
  311.     (if (not (enough-virtual-pes-p required)) (more-processors required) ())
  312.     (labels ((list-of-ctxts (allocated)
  313.            ;; generates the appropriate list of contexts
  314.                (if (>= (+ allocated MP-Config) required)
  315.          (list (make-hacked-context (- required allocated)))
  316.          (cons MP-Context (list-of-ctxts (+ allocated MP-Config))))))
  317.       (list-of-ctxts 0)))
  318.  
  319.   (defun number-segment (ctxt ofst start)
  320.     (mp-assign ctxt ofst (mp-bang ctxt 1))
  321.     (mp-set ctxt ofst 0 start)
  322.     (mp-assign ctxt ofst (mp-scan-op ctxt ofst MP_PLUS)))
  323.  
  324.   (defun get-offsets (contexts)
  325.     ;; allocates enumeration offsets for the new paralation with the
  326.     ;; given contexts, the global context enumerations are pulled from
  327.     ;; teh list of shared enumerations, a sopecial enumeration is
  328.     ;; allocated for the straggly bit at the end. get-contexts will
  329.     ;; have alloacted the extra virtual processors if needed
  330.     (labels ((list-of-ofsts (contexts offsets allocated)
  331.            ;; generate the appropriate list of offsets
  332.            (cond 
  333.         ((null contexts) ())
  334.         ((eq (car contexts) MP-Context)
  335.          (cons (car offsets) 
  336.                (list-of-ofsts (cdr contexts) (cdr offsets)
  337.                       (+ allocated MP-Config))))
  338.         (t (list (number-segment (car contexts)
  339.                      (mp-make-plural (car contexts))
  340.                      allocated))))))
  341.       (list-of-ofsts contexts MP-Offsets 0)))
  342.  
  343.   (defcondition illegal-operation ())
  344.  
  345. ; Creating a paralation means create the index field for a new
  346. ; paralation which is what we do here.
  347.  
  348.   (defun make-paralation (size)
  349.     (if (< size 1) (error "Cannot create empty paralation" illegal-operation)
  350.       (let ((new-field (make-field (allocate-paralation (get-contexts size)
  351.                             size) 'no-offsets)))
  352.     ((setter offsets) new-field (get-offsets (contexts new-field)))
  353.     ((setter index-internal) (paralation new-field) new-field)
  354.     new-field)))
  355.  
  356.  
  357. ; Obvious operations
  358. ; ======= ==========
  359.  
  360.   (defun field-ref (f i)
  361.     (let ((list-index (/ i MP-Config)))
  362.       (mp-ref (list-ref (contexts f) list-index)
  363.           (list-ref (offsets f) list-index) (remainder i MP-Config))))
  364.  
  365.   ((setter setter) field-ref (lambda (f i v)
  366.      (let ((list-index (/ i MP-Config)))
  367.        (mp-set (list-ref (contexts f) list-index)
  368.            (list-ref (offsets f) list-index) (remainder i MP-Config) v)
  369.        f)))
  370.  
  371. ; And field-length is now a slot accessor!
  372.  
  373.  
  374. ; Operation Overview
  375. ; ========= ========
  376.  
  377. ; Because the same piece of parallel code will have to run on several
  378. ; different contexts the code generated references a global called
  379. ; The-Context, mapping the code across the contexts with the first
  380. ; operation being Set-The-Context will neatly allow us to do this
  381.  
  382. ; Primitives
  383. ; ==========
  384.  
  385. ; These are the operations which wrap all the functions in the plural
  386. ; module which is implemenmted in C and mpl, the parallel versions of
  387. ; the functions are generated by macros which can be found in ppl-ll.em
  388.  
  389.   (p-1-fn mp-un-op negate MP_NEGATE)
  390.   (p-1-fn mp-un-op abs MP_ABS)
  391.   (p-2-fn mp-eq eq ())
  392.   (p-2-fn mp-cons cons ())
  393.   (p-1-fn mp-car car ())
  394.   (p-1-fn mp-cdr cdr ())
  395.   (p-1-fn mp-make-vector make-vector())
  396.   (p-1-fn mp-vector-length vector-length ())
  397.   (p-2-fn mp-vector-ref vector-ref ())
  398.   (p-1-fn mp-test consp MP_CONS)
  399.   (p-1-fn mp-test intp INTEGER)
  400.   (p-1-fn mp-test floatp MP_FLOAT)
  401.   (p-1-fn mp-test vectorp MP_VECTOR)
  402.   (p-2-fn mp-bin-op binary-plus MP_PLUS)
  403.   (p-2-fn mp-bin-op + MP_PLUS)
  404.   (p-2-fn mp-bin-op binary-difference MP_DIFFERENCE)
  405.   (p-2-fn mp-bin-op - MP_DIFFERENCE)
  406.   (p-2-fn mp-bin-op binary-times MP_TIMES)
  407.   (p-2-fn mp-bin-op * MP_TIMES)
  408.   (p-2-fn mp-bin-op binary-divide MP_DIVIDE)
  409.   (p-2-fn mp-bin-op / MP_DIVIDE)
  410.   (p-2-fn mp-rel-op binary-gt MP_GT)
  411.   (p-2-fn mp-rel-op > MP_GT)
  412.   (p-2-fn mp-rel-op binary-lt MP_LT)
  413.   (p-2-fn mp-rel-op < MP_LT)
  414.   (p-2-fn mp-bin-op remainder MP_REMAINDER)
  415.   (p-0-fn mp-random c-rand ())
  416.   (p-2-fn mp-and and ())
  417.   (p-2-fn mp-or or ())
  418.   (p-1-fn mp-not not ())
  419.   
  420.   (p-2-fn mp-assign setq ())
  421.  
  422.   (p-3-set mp-vector-set vector-ref ())
  423.   (p-2-set mp-rplac-a car ())
  424.   (p-2-set mp-rplac-d cdr ())
  425.  
  426. ; There are a few lisp functions who work in parallel - this is a hack!
  427.  
  428.   ((setter table-ref) pfun-table 'progn (cons 'progn ()))
  429.  
  430.  
  431. ; Elwise
  432. ; ======
  433.  
  434. ; The-Context hackery, global binding and a function to set it so that
  435. ; this can be exported.
  436.  
  437.   (setq The-Context 'none)
  438.  
  439.   (defun Set-The-Context (v) (setq The-Context v))
  440.  
  441. ; The heart of the rewriting operation, pull the appropriate functions
  442. ; out og the pfun-tables, bangs singular values with special hackery
  443. ; for cond, let, lambda and if.
  444.  
  445.   (defun rewire (form)
  446.     (cond 
  447.      ((consp form)
  448.       (cond
  449.        ((eq (car form) 'quote) (list 'mp-bang 'The-Context form))
  450.        ((eq (car form) (car function-name)) (cons (cadr function-name)
  451.                           (rewire (cdr form))))
  452.        ((eq (car form) 'if) (elwise-if (cadr form) (caddr form) (cadddr form)))
  453.        ((eq (car form) 'setter) (car (get-psetter (cadr form))))
  454.        ((eq (car form) 'cond) (cons 'let (cons '((cond-result 
  455.                         (mp-make-plural The-Context)))
  456.                     (cons '(mp-if The-Context (mp-bang The-Context t))
  457.                       (rewire-cond (cdr form))))))
  458.        ((eq (car form) 'lambda) (rewire-lambda (cdr form)))
  459.        ((eq (car form) 'let) (rewire-let (cdr form)))
  460.        (t (cons (if (car form) (rewire (car form)) MP-Nil)
  461.         (rewire (cdr form))))))
  462.      ((numberp form) (list 'mp-bang 'The-Context form))
  463.      ((memq form arg-list) form)
  464.      ((get-pfun form) (car (get-pfun form)))
  465.      ((null form) ())
  466.      (t (list 'mp-bang 'The-Context form))))
  467.  
  468.   (defun rewire-cond (form)
  469.     (if (null form) '((mp-fi The-Context) cond-result)
  470.       (cons
  471.        (list 'if (list 'mp-if 'The-Context (rewire (caar form)))
  472.          (list 'mp-assign 'The-Context 
  473.            'cond-result(rewire (cadar form))) ())
  474.        (cons '(mp-file The-Context)
  475.          (rewire-cond (cdr form))))))
  476.        
  477.   (defun rewire-let (form)
  478.     (let ((old-arg-list arg-list))
  479.       (setq arg-list (append (mapcar car (car form)) arg-list))
  480.       (let ((r-form (list 'let (mapcar (lambda (n-f-p)
  481.                      (cons (car n-f-p) 
  482.                            (rewire (cdr n-f-p))))
  483.                        (car form)) (cons 'progn (mapcar rewire 
  484.                                (cdr form))))))
  485.     (setq arg-list old-arg-list)
  486.     r-form)))
  487.  
  488.   (defun rewire-lambda (form)
  489.     (let ((old-arg-list arg-list))
  490.       (setq arg-list (append (car form) arg-list))
  491.       (let ((r-form (list 'lambda (car form) (rewire (cadr form)))))
  492.     (setq arg-list old-arg-list)
  493.     r-form)))
  494.  
  495.   (defun elwise-if (bool then else)
  496.     (let ((then (if then (rewire then) MP-Nil))
  497.       (else (if else (rewire else) MP-Nil)))
  498.       (list 'let '((if-result (mp-make-plural The-Context)))
  499.         (list 'if (list 'mp-if 'The-Context (rewire bool))
  500.           (list 'mp-assign 'The-Context 'if-result then) ())
  501.         (list 'if (list 'mp-else 'The-Context)
  502.           (list 'mp-assign 'The-Context 'if-result else) ())
  503.         '(mp-fi The-Context)
  504.         'if-result)))
  505.  
  506. ; This function is responsible for creating the code which sets
  507. ; everything up before the parallel code is ionvoked, creates bindings
  508. ; to offsets into the data parallel heap rather than front-end
  509. ; structures, code to evaluate any let forms in the elwise parameter
  510. ; list and extracts the book-keeping info (namely the paralation
  511. ; structure) from one of the parameter fields.
  512. ; It also sets up the arg-list, that is the list of parameter field
  513. ; which are kept in a globally accessible place so we can spot when we
  514. ; don't need to bang something.
  515.  
  516.   (defun eval-arg-list (arg-form)
  517.     (if (null arg-form)
  518.       (list (list 'the-contexts (list 'contexts (car arg-list)))
  519.         (list 'the-paralation (list 'paralation (car arg-list)))
  520.         '(the-offsets (mapcar mp-make-plural the-contexts))
  521.         '(the-result (make-field the-paralation the-offsets)))
  522.       (if (consp (car arg-form))
  523.         (progn 
  524.           (setq arg-list (cons (caar arg-form) arg-list))
  525.           (cons (car arg-form) (eval-arg-list (cdr arg-form))))
  526.         (progn 
  527.           (setq arg-list (cons (car arg-form) arg-list))
  528.           (eval-arg-list (cdr arg-form))))))
  529.  
  530.   (defun extract-offsets (arg-list) 
  531.     ;; gets the offset lists from each of the elwise parameter fields,
  532.     ;; these oo are spliced into the rewritten code. 
  533.     (mapcar (lambda (f) (list `offsets f)) arg-list))
  534.  
  535.   (defmacro elwise (arg-form body)
  536.     ;; And this is the hoopty-hoopty-doo-do macro itself which puts
  537.     ;; all the bits in the write place.
  538.     (setq arg-list ())
  539.     (setq function-name '(none))
  540.     `(let* ,(eval-arg-list arg-form)
  541.        (mapcar (lambda ,(cons `the-context 
  542.                   (cons 'result-ofst arg-list))
  543.          (let ((tmp-pspace (mp-ps-ref)))
  544.            (mp-sb-set tmp-pspace)
  545.            (Set-The-Context the-context)
  546.            (mp-assign The-Context result-ofst
  547.                   ,(if body (rewire body) 
  548.                  (list 'mp-bang 'The-Context ())))
  549.            (mp-sb-set GC-TOP)
  550.            (mp-ps-set tmp-pspace)
  551.            result-ofst))
  552.            ,@(cons `the-contexts (cons `the-offsets 
  553.                        (extract-offsets arg-list))))
  554.        the-result))
  555.        
  556. ; to add primitives, particularly recursive primitives
  557.  
  558.   (defmacro depfun (name args body)
  559.     (setq arg-list args)
  560.     (setq function-name (list name (make-pfun-name name)))
  561.     (add-pfun name (cadr function-name) args)
  562.     `(progn (defun ,(cadr function-name) ,args ,(rewire body))
  563.         (export ,(cadr function-name))))
  564.  
  565.  
  566. ; Mappings
  567. ; ========
  568.  
  569. ; Mappings describe communication bewteen paralations. They are a
  570. ; special kind of plural. Without virtualisation they are easy to
  571. ; understand. Each element of the paralation contains a list of
  572. ; processor numbers which an object should be taken from. In the
  573. ; virtualisation we have to handle the mxn combinations of contexts,
  574. ; hence rather than a list of offsets, we have a list of lists of
  575. ; offsets , which gives us all the informationwe need.
  576.  
  577.   (defclass mapping (paralation-object)
  578.     ()
  579.     constructor (make-mapping paralation offsets)
  580.     predicate mappingp)
  581.   
  582.   (defun allocate-mapping (p o)
  583.     (become-strange (make-mapping p o)))
  584.  
  585.  
  586. ; Communications
  587. ; ==============
  588.  
  589. ; Strictly speaking anything which isn't elwise I guess
  590.  
  591. ; Match
  592. ; =====
  593.  
  594. ; This is indeed a most nasty operation, zipping along lists of
  595. ; contexts and offsets at slightly different rates, not turning down a
  596. ; cdr, suddenly dropping dead of myxamatosis!
  597.  
  598.   (defun match (dest from)
  599.     (let ((result (allocate-mapping 
  600.            (paralation dest) 
  601.            (mapcar (lambda (d-c) (mapcar (lambda (f-c) 
  602.                            (mp-make-plural d-c))
  603.                          (contexts from)))
  604.                (contexts dest))))
  605.            (tmp-pspace (mp-ps-ref)))
  606.       (mp-sb-set tmp-pspace)
  607.       (labels ((seg-match (d-ctxt d-ofst r-ofsts ctxts ofsts)
  608.              (if (null ctxts) ()
  609.            (progn 
  610.              (mp-assign d-ctxt (car r-ofsts) 
  611.                   (mp-match d-ctxt d-ofst (car ctxts) (car ofsts)))
  612.              (seg-match d-ctxt d-ofst (cdr r-ofsts)
  613.                 (cdr ctxts) (cdr ofsts))))))
  614.     (mapcar (lambda (c o r) 
  615.           (seg-match c o r (contexts from) (offsets from)))
  616.         (contexts dest) (offsets dest) (offsets result))
  617.     (mp-ps-set tmp-pspace)
  618.     (mp-sb-set GC-TOP)
  619.     result)))
  620.  
  621. ; Move, several levels of move so that get and choose etc can make use
  622. ; of the appropriate bits. 
  623.  
  624.   (defun ll-move (data map initial)
  625.     ;; low-level move operation, 
  626.     (mapcar
  627.      (lambda (m-ctxt m-ofsts i-ofst)
  628.        (mapcar (lambda (d-ctxt d-ofst m-ofst)
  629.          (mp-move d-ctxt d-ofst m-ctxt m-ofst i-ofst))
  630.            (contexts data) (offsets data) m-ofsts))
  631.      (contexts map) (offsets map) (offsets initial))
  632.     (offsets initial))
  633.  
  634. ; The real meat of the operation, exceptionally nasty as this is what
  635. ; handles the nxm combinations between two virtual sets of
  636. ; communicating processors
  637.  
  638.   (defun l-move (data map p-with default)
  639.     (labels ((recurse (l-ofst cdrl-ofst)
  640.            (if (not (mp-if The-Context cdrl-ofst)) ()
  641.          (mp-assign The-Context l-ofst
  642.                 (p-with (mp-car The-Context l-ofst)
  643.                     (recurse cdrl-ofst 
  644.                          (mp-cdr The-Context cdrl-ofst)))))
  645.            (mp-else The-Context)    
  646.            (mp-assign The-Context l-ofst (mp-car The-Context l-ofst))
  647.            (mp-fi The-Context)
  648.            l-ofst))
  649.       (let ((result (make-field (paralation map)
  650.                 (mapcar mp-make-plural (contexts map))))
  651.          (tmp-pspace (mp-ps-ref)))
  652.     (mp-sb-set tmp-pspace)
  653.     (mapcar (lambda (ctxt ofst)
  654.           (mp-ps-set tmp-pspace)
  655.           (Set-The-Context ctxt)
  656.           (mp-if ctxt ofst)
  657.           (recurse ofst (mp-cdr The-Context ofst))
  658.           (mp-else ctxt)
  659.           (mp-assign ctxt ofst (mp-bang ctxt default))
  660.           (mp-fi ctxt)
  661.           ofst)
  662.         (contexts map) (ll-move data map result))
  663.     (mp-ps-set tmp-pspace)
  664.     result)))
  665.       
  666.   (defmacro move (data map with default)
  667.     `(l-move ,data ,map ,(rewire with) ,default))
  668.  
  669. ; Shaped paralations. 
  670. ; ====== ===========
  671.  
  672. ;    A shaped paralation has a predefined set of mappings which
  673. ; specify the neighbours of each element, get can be thought of as
  674. ; "each element takes it's value from the element in the given
  675. ; direction", the mappings are held in a vector in the shape slot of
  676. ; the paralation, and are extracted by the given token, e.g. N = 0.
  677. ;    We need to extend this to support shapes which do not use
  678. ; mappings, for examle rectangles making use of the nearest neighbour
  679. ; communication network of the underlying architecture. To do this we
  680. ; simply place the functions which do the move and apply this to the
  681. ; field. 
  682.  
  683.   (defun get (direction f default)
  684.     (let* ((map (vector-ref (shape f) direction))
  685.       (result (if (not (mappingp map)) (elwise (f) f)
  686.             (make-field (paralation f) (mapcar mp-make-plural
  687.                                (contexts f)))))
  688.       (tmp-pspace (mp-ps-ref)))
  689.       (mapcar (lambda (c o)
  690.         (mp-sb-set tmp-pspace)
  691.         (mp-if c o) (mp-assign c o (mp-car c o))
  692.         (mp-else c) (mp-assign c o (mp-bang c default))
  693.         (mp-fi c)
  694.         (mp-ps-set tmp-pspace) 
  695.         o)
  696.           (contexts f) (if (mappingp map) (ll-move f map result) (map result)))
  697.       (mp-sb-set GC-TOP)
  698.       result))
  699.  
  700.   (defun enum-ll (bool-f)
  701.     (let ((result (elwise (bool-f) (if bool-f 1 0)))
  702.       (tmp-pspace (mp-ps-ref)))
  703.       (labels ((recurse (c-s o-s s)
  704.          (mp-assign (car c-s) (car o-s) 
  705.                 (mp-bin-op (car c-s) 
  706.                        (mp-scan-op (car c-s) 
  707.                            (car o-s) MP_PLUS)
  708.                        (mp-bang (car c-s) s) MP_PLUS))
  709.          (if (null (cdr c-s)) ()
  710.            (recurse (cdr c-s) (cdr o-s)
  711.                 (mp-ref (car c-s) (car o-s) (- MP-Config 1))))))
  712.       (mp-sb-set tmp-pspace)
  713.       (recurse (contexts result) (offsets result) 0)
  714.       (mp-ps-set tmp-pspace)
  715.       (mp-sb-set GC-TOP)
  716.       result)))
  717.         
  718.   (defun enum (bool-f)
  719.     (elwise (bool-f (new (enum-ll bool-f))) (if bool-f (- new 1) ())))
  720.  
  721.   (defun choose (bool-f)
  722.     (let ((tmp (enum-ll bool-f)))
  723.       (match (make-paralation (field-ref tmp (- (field-length bool-f) 1)))
  724.          (elwise (tmp bool-f) (if bool-f (- tmp 1) ())))))
  725.  
  726.   (defun count (bool-f)
  727.     (field-ref (enum-ll bool-f) (- (field-length bool-f) 1)))
  728.  
  729.   (defun position (f o)
  730.     (let* ((tmp (elwise (f (i (index f))) (if (eq f o) i ())))
  731.        (tmp-pspace (mp-ps-ref))
  732.        (t-o (progn (mp-sb-set tmp-pspace) (mp-bang MP-Context 32768))))
  733.       (labels ((recurse (c-s o-s last)
  734.          (cond
  735.           ((null c-s) ())
  736.           ((not (mp-if (car c-s) (car o-s)))
  737.            (progn (mp-fi (car c-s)) 
  738.               (recurse (cdr c-s) (cdr o-s) (- last MP-Config))))
  739.           (t (progn
  740.                (mp-assign (car c-s) t-o (car o-s))
  741.                (mp-fi (car c-s))
  742.                (mp-ref (car c-s) (mp-scan-op (car c-s) t-o MP_MIN)
  743.                    (if (>= last MP-Config) (- MP-Config 1)
  744.                  (- last 1))))))))
  745.         (let ((result (recurse (contexts f) (offsets tmp) (field-length f))))
  746.       (mp-sb-set GC-TOP)
  747.       (mp-ps-set tmp-pspace)
  748.       result))))
  749.   
  750. (export depfun elwise match move make-paralation field-ref contexts offsets
  751.         index shape make-field Set-The-Context The-Context GC-TOP position
  752.     l-move choose enum count get fieldp field-length paralation
  753.     allocate-xec allocate-paralation index-internal rewire
  754.     shape-internal attributes paralation-internal
  755.     MP-Config MP-X-Config MP-Y-Config)
  756.  
  757.  
  758. )
  759.  
  760.